Cream of the Crop 26/Cream of the Crop 26.iso/program/fpkpas92.zip/SRCRTL.ZIP/RTL/DOS/MATH.INC

Text File | 1997-07-01 | 5KB | 267 lines

{****************************************************************************

                          Copyright (c) 1994 by
                            Florian Klämpfl

 ****************************************************************************}

{ Implementation der math. Routinen (nur real) }

    function abs(d : real) : real;

      begin
         asm
            fldl 8(%ebp)
            fabs
            leave
            ret $8
         end [];
      end;

    function sqr(d : real) : real;

      begin
         asm
            fldl 8(%ebp)
            fldl 8(%ebp)
            fmulp
            leave
            ret $8
         end [];
      end;

    function sqrt(d : real) : real;

      begin
         asm
            fldl 8(%ebp)
            fsqrtl
            leave
            ret $8
         end [];
      end;

    function sqrt(d : fixed) : fixed;

      begin
     asm
        movl d,%eax
        movl %eax,%ebx
        movl %eax,%ecx
        jecxz kl
        xorl %esi,%esi
     it:
        xorl %edx,%edx
        idivl %ebx
        addl %ebx,%eax
        shrl $1,%eax
        subl %eax,%esi
        cmpl $1,%esi
        jbe kl
        movl %eax,%esi
        movl %eax,%ebx
        movl %ecx,%eax
        jmp it
     kl:
        shl $8,%eax
        leave
        ret $4
      end;
      end;

    function arctan(d : real) : real;

      begin
         asm
            fldl 8(%ebp)
            fld1
            fpatan
            leave
            ret $8
         end [];
      end;

    function cos(d : real) : real;

      begin
         asm
            fldl 8(%ebp)
            fcos
            fstsw
            sahf
            jnp LCOS1
            fstp %st(0)
            fldl LCOS0
         LCOS1:
            leave
            ret    $8
         LCOS0:
            .quad    0xffffffffffffffff
         end ['EAX'];
      end;

    function exp(d : real) : real;

      begin
         asm
            // comes from DJ GPP
        fldl    8(%ebp)
        fldl2e
        fmulp
        fstcww    LCW1
        fstcww    LCW2
        fwait
        andw    $0xf3ff,LCW2
        orw    $0x0400,LCW2
        fldcww    LCW2
        fldl    %st(0)
        frndint
        fldcww    LCW1
        fxch    %st(1)
        fsub    %st(1),%st
        f2xm1
        faddl    LC0
        fscale
        fstp    %st(1)
            leave
        ret $8

            // store some help data in the data segment
        .data
    LCW1:
        .word    0
    LCW2:
        .word    0
    LC0:
        .double    0d1.0e+00

            // do not forget to switch back to text
            .text
         end;
      end;

    function frac(d : real) : real;

      begin
         asm
            subl $16,%esp
            fnstcw -4(%ebp)
            fwait
            movw -4(%ebp),%cx
            orw $0x0c3f,%cx
            movw %cx,-8(%ebp)
            fldcw -8(%ebp)
            fwait
            fldl 8(%ebp)
            frndint
            fsubl 8(%ebp)
            fabsl
            fclex
            fldcw -4(%ebp)
            leave
            ret $8
         end ['ECX'];
      end;

    function int(d : real) : real;

      begin
         asm
            subl $16,%esp
            fnstcw -4(%ebp)
            fwait
            movw -4(%ebp),%cx
            orw $0x0c3f,%cx
            movw %cx,-8(%ebp)
            fldcw -8(%ebp)
            fwait
            fldl 8(%ebp)
            frndint
            fclex
            fldcw -4(%ebp)
            leave
            ret $8
         end ['ECX'];
      end;

    function trunc(d : real) : longint;

      begin
         asm
            subl $16,%esp
            fnstcw -4(%ebp)
            fwait
            movw -4(%ebp),%cx
            orw $0x0c3f,%cx
            movw %cx,-8(%ebp)
            fldcw -8(%ebp)
            fwait
            fldl 8(%ebp)
            fistpl -8(%ebp)
            movl -8(%ebp),%eax
            fldcw -4(%ebp)
            leave
            ret $8
         end ['EAX','ECX'];
      end;

    function round(d : real) : longint;

      begin
         asm
            fnstcw -4(%ebp)
            fwait
            subl $8,%esp
            movw $0x1372,-8(%ebp)
            fldcw -8(%ebp)
            fwait
            fldl 8(%ebp)
            fistpl -8(%ebp)
            movl -8(%ebp),%eax
            fldcw -4(%ebp)
            leave
            ret $8
         end ['EAX','ECX'];
      end;

    function ln(d : real) : real;

      begin
         asm
            fldln2
            fldl 8(%ebp)
            fyl2x
            leave
            ret $8
         end [];
      end;

    function pi : real;

      begin
         asm
            fldpi
            leave
            ret
         end [];
      end;

    function sin(d : real) : real;

      begin
         asm
            fldl 8(%ebp)
            fsin
            fstsw
            sahf
            jnp LSIN1
            fstp %st(0)
            fldl LSIN0
         LSIN1:
            leave
            ret    $8
         LSIN0:
            .quad    0xffffffffffffffff
         end ['EAX'];
      end;